Pascal Super Library/Pascal Super Library (CW International)(1997).bin/COMM/RPL60/RPLLOW.INC

Text File | 1992-12-31 | 9KB | 301 lines

  {*}
  {*source code copyright (c) 1985, by TurboPower Software*}
  {*}
  {*}

  procedure Wr(s : String);
    {-shell around Wr to cut memory size}
  begin
    Write(s);
  end;

  procedure WrL(s : String);
    {-shell around WrL to cut memory size}
  begin
    WriteLn(s);
  end;

  procedure HiVid;
    {-intensify the current entryattribute}
  begin
    if CurrentMode = Mono then
      TextColor(HighMono)
    else
      TextColor(HighColor);
  end;                            {hivid}

  procedure LoVid;
    {-deintensify the current entryattribute}
  begin
    if CurrentMode = Mono then
      TextColor(LowMono)
    else
      TextColor(LowColor);
  end;                            {lovid}


  procedure Halt;
    {-replace Turbo Halt procedure with a return code version}
  begin
    System.Halt(1);
  end;                            {halt}

  procedure DefaultExtension(Extension : FileString; var InFile : FileString);
    {-assign a default extension to a DOS 2.0+ pathname}
    {extension should be a maximum of 3 characters, and does not include dot}
  var
    i              : Integer;
    Temp           : FileString;
  begin
    i := Pos('..', InFile);
    if i = 0 then
      Temp := InFile
    else
      {a pathname starting with ..}
      Temp := Copy(InFile, i+2, 64);
    i := Pos('.', Temp);
    if i = 0 then InFile := InFile+'.'+Extension;
  end;                            {defaultextension}

  procedure OpenFile(fName : FileString; var Handle : Integer);
    {-open a file for reading and return the handle}
  begin
    fName := fName+Null;
    Reg.ds := Seg(fName[1]);
    Reg.dx := Ofs(fName[1]);
    Reg.ax := $3D00;              {open for reading}
    Reg.flags := 0;
    MsDos(Dos.Registers(Reg));
    if (Reg.flags and 1) = 1 then begin
      WrL('problem opening '+fName);
      Halt;
    end;
    Handle := Reg.ax;
  end;                            {openfile}

  procedure ForceDup(Handle, NewHandle : Integer);
    {-force a dup to the newhandle number}
  begin
    Reg.bx := Handle;
    Reg.cx := NewHandle;
    Reg.ax := $4600;
    MsDos(Dos.Registers(Reg));
  end;                            {forcedup}

  function GetChunk(var l : BufLine; var Count : Integer) : Boolean;
    {-read a chunk of characters from the standard input}
    {return true if EOF reached}
  begin
    Reg.bx := InHandle;           {standard input device}
    Reg.cx := LabLen;
    Reg.ds := Seg(l[1]);
    Reg.dx := Ofs(l[1]);
    Reg.ax := $3F00;
    MsDos(Dos.Registers(Reg));
    Count := Reg.ax;
      if Count < LabLen then GetChunk := True else GetChunk := False;
  end;                            {getchunk}

  procedure CreateFile(fName : FileString; var Handle : Integer);
    {-create or rewrite a file and return the handle}
  begin
    fName := fName+Null;
    Reg.ds := Seg(fName[1]);
    Reg.dx := Ofs(fName[1]);
    Reg.cx := 0;                  {normal file}
    Reg.ax := $3C00;
    Reg.flags := 0;
    MsDos(Dos.Registers(Reg));
    if (Reg.flags and 1) = 1 then begin
      WrL('problem opening '+fName);
      Halt;
    end;
    Handle := Reg.ax;
  end;                            {createfile}

  procedure CloseFile(Handle : Integer);
    {-close a file opened by openfile}
  begin
    Reg.bx := Handle;
    Reg.ax := $3E00;
    Reg.flags := 0;
    MsDos(Dos.Registers(Reg));
    if (Reg.flags and 1) = 1 then begin
      WrL('problem closing file');
      Halt;
    end;
  end;                            {closefile}

  function IoStat(Bit : Integer) : Boolean;
    {-check status of the standard I/O}
    {bit=0 for input, 1 for output}
    {returns true if I/O is through console}
  var
    Temp0, Temp1   : Boolean;
  begin
    Reg.ax := $4400;
    Reg.bx := Bit;                {standard input or output}
    MsDos(Dos.Registers(Reg));
    Temp0 := (Reg.dx and 128) <> 0;
    Temp1 := (Reg.dx and (1 shl Bit)) <> 0;
    IoStat := Temp0 and Temp1;
  end;                            {iostat}

  procedure AppendS(var l1; Len1 : Integer; var l2; Len2 : Integer; var lOut : Line);
    {-append character object l2 to end of l1, output onto lout}
    {-using untyped parameters so that l1,l2 can be either strings or "lines"}
    {use a temp output to avoid problems when input strings are same as output}
  var
    Temp           : Line;
    RemLen         : Integer;
  begin
    {check for overflow length}
    if Len1 < LabLen then begin
      RemLen := LabLen-Len1;
      if Len2 > RemLen then Len2 := RemLen;
      {put first string onto temp}
      Move(l1, Temp.Val[1], Len1);
      {append 2nd string to temp}
      Move(l2, Temp.Val[Len1+1], Len2);
      {set length}
      Temp.Length := Len1+Len2;
    end else begin
      {lout is just l1, no room for more}
      Len1 := LabLen;
      Move(l1, Temp.Val[1], Len1);
      Temp.Length := Len1;
    end;
    {transfer onto lout}
    lOut := Temp;
  end;                            {appends}

  procedure CheckMore(var ScreenLine : Integer);
    {-see if user wants to see more}
    {call after each WrL statement}
  var
    c              : Char;
    Stop           : Boolean;
  begin
    ScreenLine := ScreenLine+1;
    if ScreenLine > 24 then begin
      Stop := False;
      Wr('....more?  ');
      c := ReadKey;
      if (c = ' ') or (UpCaseMac(c) = 'Y') then ScreenLine := 1
      else if c = ^M then ScreenLine := ScreenLine-1
      else Stop := True;
      Wr(^H^H^H^H^H^H^H^H^H^H^H); ClrEol;
      if Stop then Halt;
    end;
  end;                            {checkmore}

  procedure PutL(l : Line);
    {-send a line to the standard output}
  begin
    if ShowLines then begin
      Str(lNum:4, nStr);
      nStr := nStr+'  ';
      AppendS(nStr[1], Length(nStr), l.Val, l.Length, l);
    end;
    Reg.bx := OutHandle;
    Reg.cx := l.Length;
    Reg.ds := Seg(l.Val[1]);
    Reg.dx := Ofs(l.Val[1]);
    Reg.ax := $4000;
    MsDos(Dos.Registers(Reg));
    if (Reg.flags and 1) = 1 then begin
      WrL('');
      WrL('ERROR: cannot Wr to redirected output device....');
      Halt;
    end;
    if Reg.ax <> l.Length then begin
      WrL('');
      WrL('insufficient disk space....');
      Halt;
    end;
    if ConsoleOut then CheckMore(ScreenLine);
  end;                            {putl}

  function ReadYesNo(Default : Boolean) : Boolean;
    {-get the answer to a yes/no question and return true/false}
  var
    c              : Char;
  begin
    repeat
      c := ReadKey;
      c := UpCaseMac(c);
    until (c in ['Y', 'N', ^M]);
    if c = ^M then begin
        if Default then c := 'Y' else c := 'N';
    end;
    WrL(c);
    ReadYesNo := (c = 'Y');
  end;                            {readyesno}

  function GetCom(UsePsp : Boolean; InLin : LongString; var ErrString : Message) : Boolean;
    {-parse command line passed from DOS to Turbo Pascal}
    {return false if error encountered}
    {errstring will contain a text error message if getcom is false}
  const
    Delim          : set of Char = [' ', ^i];
    Comm           = $80;         {offset of command tail in program segment prefix}
  var
    BufPos         : Byte;        {position in command line buffer}
    TokPos         : Byte;        {position in current token}
    nChars         : Byte;        {one more than the characters in the command tail}
    c              : Char;
    m1, m2         : Message;
    Lin            : LongString;

    function ComChar : Char;
      {-return the command character at current buffer position}
    begin
      ComChar := Lin[BufPos];
      BufPos := BufPos+1;
    end;                          {comchar}

  begin                           {getcom}
    GetCom := True;
    if UsePsp then begin
      {define buffer stopping point}
      Lin := String(Ptr(PrefixSeg, $80)^);
      nChars := 1+Length(Lin);
    end else begin
      Lin := InLin;
      nChars := 1+Length(Lin);
    end;
    BufPos := 1;
    argc := 0;
    if nChars > 1 then begin
      c := ComChar;
      while (c in Delim) do c := ComChar; {skip leading blanks}
      while BufPos <= nChars do begin
        if argc < MaxTok then begin {get the next argument}
          argc := argc+1;
          TokPos := 0;
          while ((BufPos <= nChars) and (not(c in Delim))) do begin
            if TokPos < TokLen then begin {read the argument}
              TokPos := TokPos+1;
              argv[argc][TokPos] := c;
              c := ComChar;
            end else begin        {set error and skip the rest}
              GetCom := False;
              Str(argc, m1);
              Str(TokLen, m2);
              ErrString := 'ERROR: argument# '+m1+' truncated to '+m2+' characters';
              while (not(c in Delim)) do c := ComChar;
            end;
          end;
          argv[argc][0] := Chr(TokPos); {store the arg length}
          while (c in Delim) do c := ComChar; {skip blanks}
        end else begin
          GetCom := False;
          Str(MaxTok, m1);
          ErrString := 'ERROR: number of arguments truncated to '+m1;
          BufPos := nChars+1;
        end;
      end;
    end;
  end;                            {getcom}